(PROG (SEXPR IBASE)
      (SETQ IBASE (ADD1 7))
 LOOP (SETQ SEXPR (ERRSET (READ)))
      (COND ((EQ SEXPR (QUOTE $EOF$)) (ERR)))
      (PRINT (EVAL (CAR SEXPR)))
      (GO LOOP))

(DECLARE (SPECIAL BPEND BPORG KLIST QLIST)
	 (SPECIAL CONLIST GEN LOC REMOB)
	 (DEFPROP LAPERR T *FSUBR))

(DEFPROP DFUNC
	 (LAMBDA (L)
		 (LIST (Q DEFPROP)
		       (CAADR L)
		       (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
		       (Q EXPR)))
	 MACRO)

(DEFPROP ISTAG (LAMBDA (L) (CONS (Q ISIDENT) (CDR L))) MACRO)

(DEFPROP MAPDEF
	 (LAMBDA (L)
		 (LIST (Q MAPCAR)
		       (SUBST (CADR L)
			      (Q IND)
			      (Q (FUNCTION (LAMBDA (PAIR)
						   (PUTPROP
						    (CAR PAIR)
						    (CADR PAIR)
						    (QUOTE IND))))))
		       (LIST (Q QUOTE) (CDDR L))))
	 MACRO)

(DEFPROP MCONS
	 (LAMBDA (L)
		 (COND ((NULL (CDDR L)) (CADR L))
		       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
	 MACRO)

(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)

(DEFPROP RET (LAMBDA (L) (CONS (Q RETURN) (CDR L))) MACRO)

(DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)

(DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)

(DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)

(DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)

(DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)

(DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)

(DFUNC (DELETEPROP IDENT PROPNAM)
       (PROG (TEM)
	     (SETQ TEM IDENT)
	LOOP (COND ((NULL (CDR TEM)) (RET NIL)))
	     (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
					    (RET T)))
	     (SETQ TEM (CDDR TEM))
	     (GO LOOP)))

(DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))

(DFUNC (INITPROP IDENT PROPNAM PROPVAL)
       (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))

(DFUNC (SEEKPROP IDENT PROPNAM)
       (PROG (TEM)
	     (SETQ TEM (GETL IDENT (LIST PROPNAM)))
	     (COND ((NULL TEM) (RET NIL)))
	     (RET TEM)))

(DFUNC (SETPROP IDENT PROPNAM PROPVAL) (PUTPROP IDENT PROPVAL PROPNAM))

(DFUNC (ASSARGS OPCODE ARGS)
       (PROG (FIELDS WORD)
	     (SETQ FIELDS (Q ((27 . 17) (0 . 777777) (22 . 777777))))
	     (SETQ WORD (LSH OPCODE 22))
	LOOP (COND ((OR (NULL FIELDS) (NULL ARGS))
		    (RETURN WORD)))
	     (SETQ WORD
		   (PLUS WORD
			 (LSH (BOOLE 1
				     (CDAR FIELDS)
				     (LAPEVAL (CAR ARGS) LOC))
			      (CAAR FIELDS))))
	     (SETQ ARGS (CDR ARGS))
	     (SETQ FIELDS (CDR FIELDS))
	     (GO LOOP)))

(DFUNC (ASSINST INST)
       (PROG NIL
	     (LAPDEPOSIT LOC
			 (ASSARGS (GET (CAR INST) (Q OPCODE)) (CDR INST)))
	     (SETQ LOC (ADD1 LOC))))

(DFUNC (CONSTANTADDR SYM LOC)
       (PROG (N CPTR)
	     (SETQ CPTR KLIST)
	L11  (COND ((NULL CPTR) (GO L12))
		   ((EQUAL (CDR SYM) (CAAR CPTR)) (RET (CDAR CPTR))))
	     (SETQ CPTR (CDR CPTR))
	     (GO L11)
	L12  (GVAL GEN LOC)
	     (SETQ N 0)
	     (SETQ CPTR CONLIST)
	A    (COND ((NULL (CDR CPTR)) (RPLACD CPTR (LIST (CDR SYM)))))
	     (COND ((EQUAL (CDR SYM) (CADR CPTR)) (RET N)))
	     (SETQ N (ADD1 N))
	     (SETQ CPTR (CDR CPTR))
	     (GO A)))

(DFUNC (DEFLOC TAG LOC)
       (PROG (TEM)
	     (SETQ REMOB (CONS TAG REMOB))
	     (COND ((SETQ TEM (GET TAG (Q UNDEF))) (GO PATCH)))
	RET  (RET (PUTPROP TAG LOC (Q TAG)))
	PATCH(COND ((NULL TEM) (RPLACD TAG (CDDDR TAG)) (GO RET)))
	     (LAPDEPOSIT (CAR TEM) (PLUS (EXAMINE (CAR TEM)) LOC))
	     (SETQ TEM (CDR TEM))
	     (GO PATCH)))

(DEFPROP DEFSYM (LAMBDA (SYM VAL) (PUTPROP SYM VAL (QUOTE SYM))) EXPR)

(DFUNC (DOPSEUDOOP SYM LOC) ((GET (CAR SYM) (Q PSEUDOOP)) SYM LOC))

(DFUNC (GETGET ATOM PROP)
       (PROG (TEM PTAB)
	     (SETQ PTAB (FIRSTPROP ATOM))
	LOOP (COND ((LASTPROP PTAB) (RET NIL)))
	     (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP)) (RET TEM)))
	     (SETQ PTAB (NEXTPROP PTAB))
	     (GO LOOP)))

(DFUNC (GVAL SYM LOC)
       (COND ((GET SYM (Q TAG)))
	     ((GET SYM (Q SYM)))
	     ((GET SYM (Q VALUE)) (MAKNUM SYM (Q FIXNUM)))
	     (T (PUTPROP SYM (CONS LOC (GET SYM (Q UNDEF))) (Q UNDEF)) 0)))

(DFUNC (ISIDENT EX) (AND (ATOM EX) (NOT (NUMBERP EX))))

(DEFPROP LAP
	 (LAMBDA (SL)
		 (PROG (LOC CONLIST GEN REMOB L)
		       (SETQ GEN (GENSYM))
		       (SETQ CONLIST (LIST NIL))
		       (SETQ LOC BPORG)
		  A    (COND ((NULL (SETQ L (READ))) (GO END)))
		       (LAPEXPR L)
		       (GO A)
		  END  (DEFLOC GEN LOC)
		  CONST(COND ((NULL (SETQ CONLIST (CDR CONLIST)))
			      (EVAL (CONS (Q REMOB) REMOB))
			      (PUTPROP (CAR SL) (NUMVAL BPORG) (CADR SL))
			      (RET (LIST BPORG (CAR SL) (SETQ BPORG LOC)))))
		       (SETQ KLIST (CONS (CONS (CAR CONLIST) LOC) KLIST))
		       (LAPEXPR (CAR CONLIST))
		       (GO CONST)))
	 FEXPR)

(DFUNC (LAPDEPOSIT LOC WORD)
       (COND ((GREATERP LOC BPEND) (LAPERR BINARY PROGRAM SPACE EXCEEDED))
	     (T (DEPOSIT LOC WORD))))

(DEFPROP LAPERR (LAMBDA (L) (PROG2 (PRINT L) (ERR))) FEXPR)

(DFUNC (LAPEVAL EXPR LOC)
       (PROG (TEM)
	     (COND ((NUMBERP EXPR) (RETURN EXPR)))
	     (COND ((ISIDENT EXPR) (RETURN (GVAL EXPR LOC))))
	     (SETQ TEM (GETGET (CAR EXPR) (Q ADDRESSPROP)))
	     (COND ((NULL TEM) (LAPERR UNDEFINED PSEUDO OP)))
	     (RETURN ((PROPVAL TEM) EXPR LOC))))

(DFUNC (LAPEXPR EXPR)
       (COND ((ISTAG EXPR) (DEFLOC EXPR LOC))
	     ((NUMBERP EXPR) (LAPERR NUMERIC TAG))
	     ((NUMBERP (CAR EXPR))
	      (LAPDEPOSIT LOC (ASSARGS (CAR EXPR) (CDR EXPR)))
	      (SETQ LOC (ADD1 LOC)))
	     (T (PROG (TEM)
		      (COND ((SETQ TEM (GETGET (CAR EXPR) (Q WORDPROP)))
			     (RET ((PROPVAL TEM) EXPR)))
			    (T (LAPERR (UNDEFINED OPCODE))))))))

(DFUNC (QUOTEADDR SYM LOC)
       (MAKNUM (COND ((OR (NOT (ATOM (SETQ SYM (CADR SYM))))
			  (AND (NUMBERP SYM) (NOT (EQ (PLUS SYM 0) SYM)))
			  (EQ (CAR (EXPLODE SYM)) (Q /")))
		      (PROG (Y)
			    (SETQ Y QLIST)
		       A    (COND ((NULL Y)
				   (RET (CAR (SETQ QLIST
						   (CONS SYM QLIST)))))
				  ((AND (EQUAL SYM (CAR Y))
					(EQ (TYPE SYM) (TYPE (CAR Y))))
				   (RET (CAR Y))))
			    (SETQ Y (CDR Y))
			    (GO A)))
		     (T SYM))
	       (Q FIXNUM)))

(DFUNC (SPECIALADDR SYM LOC)
       (PROG NIL
	     (COND ((NULL (GET (CADR SYM) (Q VALUE)))
		    (PUTPROP (CADR SYM) (LIST NIL) (Q VALUE))))
	     (RETURN (MAKNUM (GET (CADR SYM) (Q VALUE)) (Q FIXNUM)))))

(DEFPROP TYPE (LAMBDA (X) (COND ((NUMBERP X) (CADR X)))) EXPR)

(MAPDEF ADDRESSPROP (PSEUDOOP DOPSEUDOOP))

(MAPDEF WORDPROP (OPCODE ASSINST))

(MAPDEF SYM (A 1) (B 2) (C 3) (P 14))

(MAPDEF OPCODE
	(ADD 270000) (CALL 34000) (CALLF 36000) (CALLF@ 36020) (CAIE 302000) 
	(CAIN 306000) (CAME 312000) (CAMN 316000) (CLEARB 403000) 
	(CLEARM 402000) (DPB 137000) (EXCH 250000) (HLLZS@ 513020) 
	(HLRZ 554000) (HLRZ@ 554020) (HRLM 506000) (HRLM@ 506020) (HRRM 542000) 
	(HRRZS@ 553020) (HRRZ 550000) (HRRM@ 542020) (HRRZ@ 550020) 
	(JCALL 35000) (JCALLF 37000) (JCALLF@ 37020) (JRST 254000) (JSP 265000) 
	(JUMPE 322000) (JUMPN 326000) (MOVE 200000) (MOVEI 201000) 
	(MOVEM 202000) (MOVNI 211000) (POP 262000) (POPJ 263000) (PUSH 261000) 
	(PUSHJ 260000) (SOJE 362000) (SOJN 366000) (SUB 274000) (TDZA 634000))

(MAPDEF PSEUDOOP
	(C CONSTANTADDR) (CONSTANT CONSTANTADDR) (E QUOTEADDR) 
	(FUNCTION QUOTEADDR) (QUOTE QUOTEADDR) (SPECIAL SPECIALADDR))

(COND ((NULL (GET (QUOTE QLIST) (Q VALUE))) (SETQ QLIST NIL)))

(COND ((NULL (GET (QUOTE KLIST) (Q VALUE))) (SETQ KLIST NIL)))